home *** CD-ROM | disk | FTP | other *** search
/ Software 2000 / Software 2000 Volume 1 (Disc 1 of 2).iso / education / e030.dms / e030.adf / Evolution / evolution4.f < prev    next >
Encoding:
FORTH Source  |  1989-09-24  |  11.7 KB  |  537 lines
  1. \ Evolution by Russ Yost
  2. \
  3. \ Simulate the evolution of bugs, the insect kind, that eat
  4. \ bacteria.  The bugs genes control the directions they turn.
  5. \ Bugs that find the most bacteria to eat survive better
  6. \ and pass their genes to their offspring.  Mutation and
  7. \ other aspects of evolution are modelled. See ReadMe file.
  8. \
  9. \ This program has been placed in the Public Domain by the
  10. \ author and may be freely redistributed if accompanied
  11. \ by the ReadMe file.
  12. \
  13. \ This program was written using JForth Professional 2.0
  14. \ from Delta Research
  15.  
  16. getmodule includes
  17. include? gr.init ju:amiga_graph
  18. include? ?closebox ju:amiga_events 
  19. include? :struct ju:c_struct
  20. include? wchoose ju:random
  21. include? value ju:value
  22.  
  23. anew task-bugs
  24. forth definitions
  25.  
  26. newwindow bugwindow
  27.  
  28. 10 constant gr_xmin   620 constant gr_xmax
  29. gr_xmax gr_xmin - constant gr_xspan
  30.  
  31. 5 constant gr_ymin   137 constant gr_ymax
  32. gr_ymax gr_ymin - constant gr_yspan
  33.  
  34. 65534 constant sf \ scale factor for random integer genes
  35. 65535 constant sf+1 \ random number multiplier
  36.  
  37. 750 constant bact0   variable bact-rate variable bugs-to-do
  38. variable g.e.mode   false g.e.mode !
  39. 4 constant g.e.lim \ of each of 12  uniform dist'n summed to get
  40. \ pseudo-Gaussian distribution.
  41. 10 constant max.tries 
  42.  
  43. \ variable n-time   
  44.  
  45. 32 constant n-rpt \ output status after processing n-rpt bugs.
  46.  
  47. 40 constant bacte    600 constant bugemax 10 constant bugs0
  48.  
  49. variable numbugs     
  50.  
  51. variable mature   200 mature ! variable too.old  
  52. mature @ 10 * too.old !
  53. variable strong   400 strong !
  54. variable child.e   40 child.e !
  55. variable child.e.half   false child.e.half !
  56.  
  57. create xmoves   0 , 4 , 4 , 0 , -4 , -4 ,
  58. create ymoves   2 , 1 , -1 , -2 , -1 , 1 ,
  59.  
  60. : get.params \ future use to set parameters. May require changing
  61. \ some constants to variables.
  62. ;
  63.  
  64. 6 array geneavs
  65.  
  66. :struct bugdat
  67.   aptr bg_prev
  68.   aptr bg_next
  69.   short bg_x
  70.   short bg_y
  71.   short bg_dir
  72.   7 4 * bytes bg_gene
  73.   short bg_e
  74.   short bg_a
  75. ;struct
  76.  
  77. \ Set up initial bugstructs in fast mem.
  78.  
  79. 0 value bug0    0 value bug1 \ Inlz self-fetching bugpointers.
  80.  
  81. : make.bug0 ( -- bgptr )
  82.   memf_fast sizeof() bugdat allocblock
  83.   dup 0= abort" Can't make bug0." dup -> bug0
  84. ;
  85.  
  86. : make.bug1 ( --  bgptr )
  87.   memf_fast sizeof() bugdat allocblock
  88.   dup 0= abort" Can't make bug1." dup -> bug1
  89. ;
  90.  
  91. : bact.set ( x, y -- , paint color 3 bacterium,  )
  92.   gr.color@ >r 3 gr.color!
  93.   2dup gr.move  gr.draw
  94.   r> gr.color! ;
  95.  
  96.  
  97. : init.rand rand-seed >abs dup call intuition_lib CurrentTime drop ;
  98.  
  99.  
  100.  
  101.  
  102. : rx gr_xmax gr_xmin wchoose 2/ 2* ; \ To align bugs and bacts
  103. : ry gr_ymax gr_ymin wchoose ;       \ and to reduce search time in eating.
  104. : rdir 6 choose ;
  105.  
  106. : grx ( -- x ) \ Gaussian distn at ctr of window
  107.     0   12 0 do
  108.     g.e.lim 2* 1+ dup negate 1+ wchoose +
  109.                loop
  110.     gr_xmax gr_xmin + 2/ + 2/ 2*
  111. ;
  112.  
  113. : gry ( -- y ) \ Gaussian distn at ctr of window
  114.       0   12 0 do
  115.                g.e.lim 1+ dup negate 1+ wchoose + 
  116.            loop
  117.       gr_ymax gr_ymin + 2/ +
  118. ;
  119.  
  120. : g.e.rand.bact.set ( -- ) \ look for clear spot for max.tries, 
  121.                            \ put bact in Raleigh Distn.
  122.   0 ( inlz counter ) 0 dup ( inlz x, y )
  123.   begin
  124.     2drop 1+ ( inc. cntr ) grx gry 2dup
  125.     gr-currport @ -rot call graphics_lib ReadPixel
  126.     0=
  127.     3 pick max.tries >   or
  128.   until
  129.   >r >r drop r> r>
  130.   bact.set
  131. ;
  132. : rand.bact.set ( --   ; look for a clear spot before putting a bact. ) 
  133.   0 dup
  134.   begin
  135.     2drop rx ry 2dup
  136.     gr-currport @ -rot call graphics_lib ReadPixel
  137.     0=
  138.   until
  139.   bact.set
  140. ;
  141.  
  142. : rand.bacts.add ( -- )
  143.   bact-rate @
  144.   begin
  145.   dup 0>
  146.   while
  147.     g.e.mode @ if g.e.rand.bact.set
  148.                else rand.bact.set
  149.            then
  150.     1-
  151.   repeat
  152.   drop
  153. ;
  154.  
  155.  
  156. : getxy ( bgptr -- bgptr x y )
  157.   dup ..@ bg_x over ..@ bg_y
  158. ;
  159.  
  160. : bug.paint ( bgptr  -- bgptr ) ( uses existing gr.color )
  161.  \ if = background color, clears existing bug.
  162.   getxy ( -- bgptr, x, y  ; x,y is lower left corner of 4x2 bug )
  163.   1- over 3 + over 1+ gr.rect
  164. ;
  165.  
  166. : bug.set ( bgptr  -- bgptr )
  167.   gr.color@ >r 
  168.   dup ..@ bg_e dup 
  169.   child.e @ 80 + >
  170.   if drop 1
  171.   else child.e @ > 
  172.     if   3 else  2
  173.     then
  174.   then
  175.   gr.color!
  176.   bug.paint
  177.   r> gr.color!
  178. ;
  179. : bug.clear ( bgptr -- bgptr )
  180.   gr.color@ >r 0 gr.color!
  181.   bug.paint  
  182.   r> gr.color!
  183. ;
  184.  
  185.  
  186.  
  187. : make,link.inl.pair ( -- )
  188.   bug0 dup 0= if drop make.bug0 then
  189.   bug1 dup 0= if drop make.bug1 then
  190.   over over ..! bg_prev
  191.   over over ..! bg_next
  192.   swap
  193.   over over ..! bg_prev
  194.             ..! bg_next
  195. ;
  196.  
  197. : inlz.initial.bug.genes ( bgptr -- bgptr )
  198.   dup .. bg_gene
  199.   0 over !
  200.   7 1 do 6000 choose
  201.          over i 1- cells + @ +  
  202.          over i cells + ! loop drop
  203. ;
  204.  
  205. : inlz.xydea ( bgptr -- bgptr )
  206.   rx over ..! bg_x
  207.   ry over ..! bg_y
  208.   rdir over ..! bg_dir
  209.   bacte over ..! bg_e
  210.   0 over ..! bg_a
  211. ;
  212.  
  213. : make.nu.bug ( bgptr --  nubgptr )
  214.   memf_fast   sizeof() bugdat allocblock ( bgptr,  nubgptr | false)
  215.   dup 0= abort" Can't make new bug. " 
  216.   ( bgptr, nubgptr )
  217.     over ..@ bg_next dup >r ( b0ptr , nubptr, nxtbptr )
  218.   over ..! bg_next ( b0ptr, nubgptr )
  219.   r@ ..@ bg_prev over ..! bg_prev
  220.   dup rot ..! bg_next
  221.   dup r> ..! bg_prev
  222.   1 numbugs +!
  223. ;  
  224.  
  225.  
  226. : inlz.bug.data ( bgptr -- bgptr )
  227.   inlz.initial.bug.genes inlz.xydea bug.set
  228. ;
  229.  
  230. : inlz.set.bugs ( -- )
  231.   make,link.inl.pair
  232.   bug0 inlz.bug.data drop bug1 inlz.bug.data drop
  233.   2 numbugs !
  234.   bug0 \ add nu bugs after bug0.
  235.   bugs0 2 - 0 do make.nu.bug inlz.bug.data  loop drop
  236. ;
  237.  
  238. : get.next.bug ( bgptr -- nextbgptr )
  239.   ..@ bg_next
  240. ;
  241.  
  242. : .gr.prob. ( n --  ; print n as decimal fractn )
  243.   " ." gr.text   dup 100 < 
  244.   if 0 gr.number
  245.   then  dup 10 <
  246.   if 0 gr.number
  247.   then
  248.   gr.number
  249. ;
  250.  
  251. : .avg.genes ( bgptr -- bgptr )
  252.   6 0 do 0 i geneavs ! loop
  253.   dup >r \ save for comparison to detect complete chain
  254.   begin ( bgptr )
  255.     dup .. bg_gene ( bgptr, genebase )
  256.     7 1 do   dup i cells + @
  257.           over i 1- cells + @
  258.       -   1000   2 pick 24 + @   */
  259.       i 1- geneavs +!
  260.     loop   drop ( bgptr )
  261.     get.next.bug ( nextbgptr )   dup r@ =
  262.   until 
  263.   r> drop   numbugs @
  264.   6 0 do i geneavs @ over / .gr.prob.  " ; " gr.text 
  265.       loop   drop
  266. ;
  267.  
  268. : report ( bgptr, -- bgptr )
  269.     0 145
  270. " Turn, degrees :                       0     60    120   180   240   300"
  271.     gr.xytext
  272.     0 155 " # Bugs: " gr.xytext numbugs @ 
  273.     dup 100 < if "  " gr.text then
  274.     dup 10  < if "  " gr.text then gr.number
  275.     " ; Avg Gene Probabilities: " gr.text    .avg.genes
  276.     520 170 "      " gr.xytext
  277.     520 170 gr.move bact-rate @ 
  278.     bacte * 2/   gr.number 
  279. ;
  280.  
  281. : test.kill.bug ( bgptr -- bgptr | nextbgptr )
  282.   numbugs @ 2 >
  283.   if
  284.     dup ..@ bg_e 0=
  285.     over ..@ bg_a   too.old @ >   or
  286.     if
  287.       bug.clear
  288.       dup ..@ bg_prev
  289.       over ..@ bg_next
  290.       dup 2 pick ..! bg_next
  291.       over over ..! bg_prev
  292.       -rot drop ( nextbugptr, bgptr )
  293.       dup bug0 = if 0 -> bug0  else dup bug1 = if 0 -> bug1  then then
  294.       freeblock \ Return dead bug's memory space.
  295.       -1 numbugs +!
  296.       report
  297.     then
  298.   else
  299.     dup ..@ bg_e 0 max over ..! bg_e \ Keep last two bugs energy positive. 
  300.   then
  301. ; 
  302.  
  303. : getturn ( bugstructureptr -- same; bugdir[n] changed per genes )
  304.   dup .. bg_gene
  305.   dup 6 cells + @ choose ( bptr, g0, pturn )
  306.   0 dup ( bptr, g0, pturn, ix, T0 )
  307.   begin
  308.     2 pick <   
  309.     swap 4 +    dup 24 <   rot and
  310.   while  ( bp, g0, pturn, index )
  311.     dup 3 pick + @   
  312.   repeat ( bp, g0, pturn, selected index )
  313.   4 / 2-   >r 2drop r> ( bp, selected.turn in 0..5 range )
  314.   over ..@ bg_dir + 6 mod
  315.   over ..! bg_dir
  316. ;
  317.  
  318. : getnuxy ( bgptr -- bgptr )
  319.   dup ..@ bg_dir dup >r
  320.   cells   xmoves + @ (  bugptr, delx )
  321.   over ..@ bg_x + (  bugptr, newx )
  322.   gr_xmax over <
  323.   if gr_xspan -
  324.   else gr_xmin over >
  325.     if gr_xspan +
  326.     then
  327.   then
  328.   over ..! bg_x (  bugptr )
  329.   r> ( get dir )
  330.   cells ymoves + @
  331.   over ..@ bg_y + ( bgptr, ytrial )
  332.   gr_ymax over <
  333.   if gr_yspan -
  334.   else gr_ymin over >
  335.     if gr_yspan +
  336.     then
  337.   then
  338.   over ..! bg_y
  339.   dup ..@ bg_a 1+
  340.   over ..! bg_a
  341.   dup ..@ bg_e 1-
  342.   over ..! bg_e
  343. ;
  344.  
  345. : eat.bact ( bgptr, x, y, port, xf, port, xf, yf --- bgptr, x, y, port, xf )
  346.   call graphics_lib ReadPixel ( bgptr, x, y, port, xf, color.id )
  347.   3 =
  348.   if
  349.      
  350.      4 pick ..@ bg_e   bacte +
  351.      dup bugemax  >
  352.      if
  353.        drop bugemax
  354.      then
  355.      5 pick ..! bg_e
  356.   then
  357. ;
  358. : eat.bg.bacts ( bgptr -- bgptr )
  359.   dup  ..@ bg_x over ..@ bg_y  gr-currport @ ( bgptr, x, y, port )
  360.   4 0 do
  361.           2 pick  i + ( bp, x, y, port, xf
  362.       2 0  do 
  363.               2dup 4 pick i -   eat.bact
  364.                loop drop 
  365.           2 +loop 2drop drop
  366. ;
  367.  
  368.  
  369. : copy.bug.data ( srcbgptr, destbgptr -- same )
  370.   over ..@ bg_x    over ..! bg_x
  371.   over ..@ bg_y    over ..! bg_y
  372.   over ..@ bg_dir  over ..! bg_dir
  373.   over ..  bg_gene over ..  bg_gene 28 move
  374. ;
  375.  
  376. : div.all.genes.by.2 ( bptr -- bptr )
  377.   dup .. bg_gene
  378.   28 4 do dup i + dup @ 2/ swap !
  379.           cell +loop drop
  380. ;
  381.  
  382. : inc.rand.gene ( bgptr -- )
  383.   rdir   1+   dup >r
  384.   over .. bg_gene   dup >r
  385.   swap cells +    dup @
  386.   swap 4 - @   - ( bgptr, Ti-Ti-1 )
  387.   r> r> cells
  388.   begin ( bgptr, delT, g0, ix )
  389.     2dup  +   3 pick swap +!
  390.     4 +   dup 24 >
  391.   until
  392.   + 4 - @ ( bgptr, delT, T6 [=sum] )
  393.   >r drop r>   
  394.   65535 > if div.all.genes.by.2   then drop
  395. ; 
  396.     
  397. : dec.rand.gene ( bgptr -- )
  398.   rdir 1+ dup >r
  399.   over .. bg_gene   dup >r
  400.   swap cells + dup @
  401.   swap 4 - @   -   2/ negate ( bgptr, delT )
  402.   r> r> cells ( bp, delT, g0, ix )
  403.   begin
  404.     2dup + dup @ 4 pick +   swap !
  405.     4 +   dup 24 >
  406.   until 
  407.   2drop 2drop
  408. ;
  409.  
  410. : fission ( bgptr -- bgptr )
  411.   dup ..@ bg_a   mature @ >
  412.   if
  413.     dup ..@ bg_e   strong @ >
  414.     if
  415.       dup make.nu.bug ( oldbgptr, nubgptr )
  416.       copy.bug.data ( oldbgptr, nubgptr )
  417.       over inc.rand.gene
  418.       dup dec.rand.gene
  419.       child.e.half @ 
  420.       if
  421.         over ..@ bg_e 2/
  422.       else
  423.         child.e @
  424.       then
  425.       dup 3 pick ..! bg_e
  426.       over ..! bg_e ( oldbgptr, nubugptr )
  427.       0 dup 2 pick ..! bg_a 2 pick ..! bg_a   drop
  428.       report
  429.     then
  430.   then
  431. ;
  432.  
  433.  
  434.  
  435.  
  436. : chng.bact ( 67 | 68 | 69 --  )
  437. \ If n = 67, toggle g.e.mode.
  438. \ If n = 68, decrements bact-rate by 1, but not < 0;
  439. \ If n = 69, increments bact-rate by 1;
  440. \ else doesn't change nubact.
  441.   case 67 of g.e.mode dup @ true xor swap ! 0 endof
  442.        68 of -1     endof
  443.        69 of  1     endof
  444.        0 swap
  445.   endcase    bact-rate +!
  446.   bact-rate dup @ 0<
  447.   if 0 swap ! else drop then  
  448. ;
  449.  
  450. : make.buttons ( -- ) ( Adapted from Delta Research )
  451.   0 160   60 175   gr.rect
  452.   80 160   140 175   gr.rect
  453.   160 160   310 175   gr.rect
  454.   JAM1 gr.mode!   0 gr.color!
  455.   10 170 " Dec." gr.xytext
  456.   90 170 " Inc." gr.xytext
  457.   170 170 " Uniform/Conc." gr.xytext
  458.   JAM2 gr.mode!   1 gr.color!
  459. ;
  460.  
  461. : check.input ( bugptr -- bugptr quitflag )
  462.     gr-curwindow @ ev.getclass ?dup
  463.     IF
  464.         CASE
  465.             MOUSEBUTTONS OF
  466.                 ev-last-code @ SELECTDOWN =  
  467.                 IF ev.getxy00 ( Xm, Ym -- )   150 >
  468.                    IF ( Xm )
  469.                       dup 320 <
  470.                       if
  471.                         dup 80 <
  472.                             if
  473.                               drop 68 chng.bact report
  474.                             else
  475.                             160 <
  476.                                 if 
  477.                                     69 chng.bact report
  478.                                 else
  479.                                   67 chng.bact
  480.                                 then
  481.                             then
  482.                       else drop
  483.                       then
  484.                   else drop
  485.                   then
  486.                 then false
  487.             endof
  488.             CLOSEWINDOW of   true   endof
  489.             false   swap
  490.         endcase
  491.     else false
  492.     then
  493. ;   
  494.  
  495. : evolve ( -- )
  496.   gr.init ( to be certain )
  497.   bugwindow  newwindow.setup 
  498.   bugwindow 
  499.   0" Bug Evolution R.Yost" >abs over  ..! nw_Title
  500.   190 swap ..! nw_Height
  501.   CLOSEWINDOW MOUSEBUTTONS | bugwindow ..! nw_idcmpflags
  502.   bugwindow gr.opencurw not abort" Couldn't open window."
  503.   1 gr.color! \ Set foreground color to white.
  504.     make.buttons
  505.     320 170 " New bacts supplied for ~       bugs" gr.xytext
  506.   init.rand
  507.   get.params 
  508.   bact0 bact-rate ! 
  509.   rand.bacts.add
  510.   1 bact-rate !
  511.    inlz.set.bugs
  512.   numbugs @ 2* bugs-to-do !
  513.   bug0
  514.   report
  515.   begin
  516.     n-rpt 0 DO
  517.     eat.bg.bacts
  518.     bug.set
  519.     test.kill.bug
  520.     get.next.bug
  521.     fission
  522.     getturn
  523.     bug.clear
  524.     getnuxy
  525.     bugs-to-do dup >r @ 1- dup r> ! 0=
  526.     if 
  527.        rand.bacts.add
  528.        numbugs @ 2* bugs-to-do ! 
  529.     then
  530.     LOOP
  531.     check.input    
  532.   until
  533.   drop  gr.closecurw gr.term 
  534. ;
  535.  
  536. cr ." Enter:    EVOLVE     to run program." cr
  537.